Temel Bilesenler Analizi

library(dplyr)  
library(FactoMineR) #PCA icin lullanilan paket.
library(factoextra) #Grafikler icin gerekli paket.
library(ggplot2)
library(RColorBrewer) #Renklerin bulundugu paket
library(fastICA) #ICA icin kullanilan paket
library("MASS")

data=read.csv("~/Desktop/ist.yazılım proje/cancer.csv")
veri<-data[,-33]
str(veri)

## 'data.frame':    569 obs. of  32 variables:
##  $ id                     : int  842302 842517 84300903 84348301 84358402 843786 844359 84458202 844981 84501001 ...
##  $ diagnosis              : chr  "M" "M" "M" "M" ...
##  $ radius_mean            : num  18 20.6 19.7 11.4 20.3 ...
##  $ texture_mean           : num  10.4 17.8 21.2 20.4 14.3 ...
##  $ perimeter_mean         : num  122.8 132.9 130 77.6 135.1 ...
##  $ area_mean              : num  1001 1326 1203 386 1297 ...
##  $ smoothness_mean        : num  0.1184 0.0847 0.1096 0.1425 0.1003 ...
##  $ compactness_mean       : num  0.2776 0.0786 0.1599 0.2839 0.1328 ...
##  $ concavity_mean         : num  0.3001 0.0869 0.1974 0.2414 0.198 ...
##  $ concave.points_mean    : num  0.1471 0.0702 0.1279 0.1052 0.1043 ...
##  $ symmetry_mean          : num  0.242 0.181 0.207 0.26 0.181 ...
##  $ fractal_dimension_mean : num  0.0787 0.0567 0.06 0.0974 0.0588 ...
##  $ radius_se              : num  1.095 0.543 0.746 0.496 0.757 ...
##  $ texture_se             : num  0.905 0.734 0.787 1.156 0.781 ...
##  $ perimeter_se           : num  8.59 3.4 4.58 3.44 5.44 ...
##  $ area_se                : num  153.4 74.1 94 27.2 94.4 ...
##  $ smoothness_se          : num  0.0064 0.00522 0.00615 0.00911 0.01149 ...
##  $ compactness_se         : num  0.049 0.0131 0.0401 0.0746 0.0246 ...
##  $ concavity_se           : num  0.0537 0.0186 0.0383 0.0566 0.0569 ...
##  $ concave.points_se      : num  0.0159 0.0134 0.0206 0.0187 0.0188 ...
##  $ symmetry_se            : num  0.03 0.0139 0.0225 0.0596 0.0176 ...
##  $ fractal_dimension_se   : num  0.00619 0.00353 0.00457 0.00921 0.00511 ...
##  $ radius_worst           : num  25.4 25 23.6 14.9 22.5 ...
##  $ texture_worst          : num  17.3 23.4 25.5 26.5 16.7 ...
##  $ perimeter_worst        : num  184.6 158.8 152.5 98.9 152.2 ...
##  $ area_worst             : num  2019 1956 1709 568 1575 ...
##  $ smoothness_worst       : num  0.162 0.124 0.144 0.21 0.137 ...
##  $ compactness_worst      : num  0.666 0.187 0.424 0.866 0.205 ...
##  $ concavity_worst        : num  0.712 0.242 0.45 0.687 0.4 ...
##  $ concave.points_worst   : num  0.265 0.186 0.243 0.258 0.163 ...
##  $ symmetry_worst         : num  0.46 0.275 0.361 0.664 0.236 ...
##  $ fractal_dimension_worst: num  0.1189 0.089 0.0876 0.173 0.0768 ...

veri %>% dim

## [1] 569  32

Temel Bilesenleri Olusturalım

library(FactoMineR)
pca <- prcomp(veri[c(3:32)], center = TRUE, scale = TRUE)
summary(pca)

## Importance of components:
##                           PC1    PC2     PC3     PC4     PC5     PC6     PC7
## Standard deviation     3.6444 2.3857 1.67867 1.40735 1.28403 1.09880 0.82172
## Proportion of Variance 0.4427 0.1897 0.09393 0.06602 0.05496 0.04025 0.02251
## Cumulative Proportion  0.4427 0.6324 0.72636 0.79239 0.84734 0.88759 0.91010
##                            PC8    PC9    PC10   PC11    PC12    PC13    PC14
## Standard deviation     0.69037 0.6457 0.59219 0.5421 0.51104 0.49128 0.39624
## Proportion of Variance 0.01589 0.0139 0.01169 0.0098 0.00871 0.00805 0.00523
## Cumulative Proportion  0.92598 0.9399 0.95157 0.9614 0.97007 0.97812 0.98335
##                           PC15    PC16    PC17    PC18    PC19    PC20   PC21
## Standard deviation     0.30681 0.28260 0.24372 0.22939 0.22244 0.17652 0.1731
## Proportion of Variance 0.00314 0.00266 0.00198 0.00175 0.00165 0.00104 0.0010
## Cumulative Proportion  0.98649 0.98915 0.99113 0.99288 0.99453 0.99557 0.9966
##                           PC22    PC23   PC24    PC25    PC26    PC27    PC28
## Standard deviation     0.16565 0.15602 0.1344 0.12442 0.09043 0.08307 0.03987
## Proportion of Variance 0.00091 0.00081 0.0006 0.00052 0.00027 0.00023 0.00005
## Cumulative Proportion  0.99749 0.99830 0.9989 0.99942 0.99969 0.99992 0.99997
##                           PC29    PC30
## Standard deviation     0.02736 0.01153
## Proportion of Variance 0.00002 0.00000
## Cumulative Proportion  1.00000 1.00000

Burada prcom komutuyla temel bilesenleri kolay bir sekilde hesaplayabildik.Bu komutla veriyi hem olcekleyip hemde merkezlemis oluyoruz.

Pca ya bakarsak ozvektor ve ozdegerlerden olustugunu gorebiliriz.

#özvektor
pca$rotation [,1:10] %>% head(1) 

##                    PC1       PC2          PC3        PC4         PC5        PC6
## radius_mean -0.2189024 0.2338571 -0.008531243 0.04140896 -0.03778635 0.01874079
##                    PC7         PC8        PC9       PC10
## radius_mean -0.1240883 0.007452296 -0.2231098 0.09548644

pca$x[,1:10] %>% head(1) 

##            PC1      PC2       PC3      PC4      PC5      PC6      PC7      PC8
## [1,] -9.184755 -1.94687 -1.122179 3.630536 1.194059 1.410184 2.157472 0.398057
##             PC9       PC10
## [1,] -0.1569802 -0.8766305

#sdev:özdeger
pca$sdev

##  [1] 3.64439401 2.38565601 1.67867477 1.40735229 1.28402903 1.09879780
##  [7] 0.82171778 0.69037464 0.64567392 0.59219377 0.54213992 0.51103950
## [13] 0.49128148 0.39624453 0.30681422 0.28260007 0.24371918 0.22938785
## [19] 0.22243559 0.17652026 0.17312681 0.16564843 0.15601550 0.13436892
## [25] 0.12442376 0.09043030 0.08306903 0.03986650 0.02736427 0.01153451

plot1 <- cor(pca$x, method="pearson")
corrplot::corrplot(plot1, method= "color", order = "hclust", tl.pos = 'n')

PVE <- (pca$sdev^2 / sum(pca$sdev^2))
round(PVE, 2)

##  [1] 0.44 0.19 0.09 0.07 0.05 0.04 0.02 0.02 0.01 0.01 0.01 0.01 0.01 0.01 0.00
## [16] 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00

library(factoextra)
fviz_eig(pca, addlabels = TRUE, ylim = c(0, 50))

Acıklananvaryans <- function(eigen) {

par(mfrow = c(1,2))
cumsum(pca$sdev^2 / sum(pca$sdev^2))
plot(
 pca$sdev^2 / sum(pca$sdev^2), pch = 21, col = 'black',
 bg = '#549cc4', ylim = c(0, 1), xlab = 'Temel Bilesenler',
 ylab = 'Acıklanan Varyans'
 ) + abline(h = 0.9)

plot(
 cumsum(pca$sdev^2 / sum(pca$sdev^2)), pch = 21,
 col = 'black', bg = '#549cc4', ylim = c(0, 1), xlab = 'Temel Bilesenler',
 ylab = 'Acıklanan Kumulatif Varyans'
 ) + abline(h = 0.9)
}

Acıklananvaryans(pca)

## integer(0)

PVE <- (pca$sdev^2 / sum(pca$sdev^2))
round(PVE, 2)

##  [1] 0.44 0.19 0.09 0.07 0.05 0.04 0.02 0.02 0.01 0.01 0.01 0.01 0.01 0.01 0.00
## [16] 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00

fviz_pca_ind(pca, geom.ind = "point", pointshape = 21, 
             pointsize = 2, 
             fill.ind = veri$diagnosis, 
             col.ind = "black", 
             palette = "jco", 
             addEllipses = TRUE,
             label = "var",
             col.var = "black",
             repel = TRUE,
             legend.title = "Tanı") +
  ggtitle("2-Boyutlu PCA Grafigi") +
  theme(plot.title = element_text(hjust = 0.5))

Temel Bilesenlerle Yuz Tanima

Temel bilesen yuksek boyutlu verilerde kullanilir.Yuz tanıma icin ise buyuk bir matrisi sikistirip daha dusuk bir boyuta getirecegiz. Burada 32 × 32 faceData matrisini kullanacagiz.

Sekil 1: facedatamatrix

load('~/Downloads/face.rda')
runPCA <- function(mat = 'Unadjusted matrix') eigen(cov(apply(mat, 2, function(i) i - mean(i))))
pca2 <- runPCA(faceData)

Aciklananvaryans2 <- function(eigenList) {

par(mfrow = c(1,2))

plot(
 eigenList$value / sum(eigenList$value), pch = 21, col = 'black',
 bg = '#549cc4', ylim = c(0, 1), xlab = 'Temel Bilesenler',
 ylab = 'Acıklanan Varyans'
 ) + abline(h = 0.9)

plot(
 cumsum(eigenList$value) / sum(eigenList$value), pch = 21,
 col = 'black', bg = '#549cc4', ylim = c(0, 1), xlab = 'Temel Bilesenler',
 ylab = 'Acıklanan Kumulatif Varyans'
 ) + abline(h = 0.9)
}

Aciklananvaryans2(pca2)

## integer(0)

afterPCA <- function(
 matAdjust = 'Centered matrix',
 meanList = 'List of column means of original (unadjusted) matrix',
 eigenList = 'List of eigenvalues and eigenvectors of adjust matrix covariance matrix',
 n = 'selected PC\'s',
 specific_select = 'If True: n == 1:n, if False: just n\'th columns') {

 if (length(n) > ncol(matAdjust)) stop('N is higher than the number of PC\'s')
 if (!specific_select & length(n) > 1) stop('Use a single number when selecting up to n\'th PC')
 if (!specific_select) n <- 1:n

 t(eigenList$vectors[,n] %*% (t(eigenList$vectors[,n]) %*% t(matAdjust))) + t(matrix(meanList, nrow = nrow(matAdjust), ncol = ncol(matAdjust)))
}


showMatrix <- function(x, ...) image(t(x[nrow(x):1,]), xaxt = 'none', yaxt = 'none', col = rev(colorRampPalette(brewer.pal(7, 'Blues'))(100)), ...)

reconstMatrix <- afterPCA(
 matAdjust = apply(faceData, 2, function(i) i - mean(i)),
 meanList = apply(faceData, 2, mean),
 eigenList = pca2,
 n = 5,
 specific_select = FALSE
)

par(mfrow = c(1,2), mar = c(0, 0, 1, 0), bty = 'n')
showMatrix(faceData, main = 'Original Matrix')
showMatrix(reconstMatrix, main = 'First 5 PC\'s')

Bagimsiz Bilesenler Analizi

İki Bagimsiz Tonu Dogrusal Karisimlarindan Cikarma Katki Gauss Gurultusunun Bozulmus Tonlarinin Uretilmesi

ICA, bagimsiz kaynakları karısık bir sinyalden ayırmak icin kullanılan bir makine ögrenme teknigidir. Oncelikli olarak ICA bagimsiz bilesenlere odaklanır, uygulamamızda bagimsiz iki farklı ton olarak adlandirilabilecek iki farklı matris olusturuyoruz.

ton1=0.7*sin((1:1000)/19+0.57*pi) + MASS::mvrnorm(n = 1000, mu = 0, Sigma = 0.004) # Tone 1 corrupted by noise
ton1 <- as.numeric(ton1)
plot(ton1, main = "Katkı Gürültüsü - Bozuk Ton 1", xlab = "Zaman", ylab = "Genlik")

ton2=sin((1:1000)/33) + MASS::mvrnorm(n = 1000, mu = 0.03, Sigma = 0.005) # Tone 2 corrupted by noise
ton2 <- as.numeric(ton2)
plot(ton2, main = "Katkı Gürültüsü - Bozuk Ton 2", xlab = "Zaman", ylab = "Genlik")

Olusturulan bagimsiz tonların ayni anda ciktigini varsaydigimizda farklı bir matris A tarafindan verilen konum ve ayarlara göre karisik iki farkli sinyal uretir. Uretilen iki farkli sinyali asagidaki gibi dogrusal karisik sinyal olarak belirtiyoruz. Aslinda üretilen ton1 ve ton2 iki farkli sinyal üretmiştir diyebiliriz.

Deterministik Dogrusal Karıstırma

signal1 <- ton1-2*ton2
plot(signal1, xlab = "Zaman", ylab = "Genlik",col="gray34")+
title(main = "Doğrusal Karışık Sinyal", sub = "Sinyal 1",
      xlab = "Zaman", ylab = "Genlik",
      cex.main = 1.3,   font.main= 4, col.main= "lightcoral",
      cex.sub = 0.75, font.sub = 2, col.sub = "indianred3",
      col.lab ="indianred3" )

## integer(0)

signal2 <- 1.73*ton1 +3.41*ton2
plot(signal2, xlab = "Zaman", ylab = "Genlik", col="gray34")+
  title(main = "Dogrusal Karisik Sinyal", sub = "Sinyal 2",
      xlab = "Zaman", ylab = "Genlik",
      cex.main = 1.3,   font.main= 4, col.main= "lightcoral",
      cex.sub = 0.75, font.sub = 3, col.sub = "lightpink4",
      col.lab ="lightpink4"
      )

## integer(0)

Karisik sinyaller(sinyal1 ve sinyal2) cikti olarak sinyal adini verdigimiz vektörü üretir.Buna kokteyl partisi sorunu diyoruz.

Sekil2: Koktely Partisi Sorunu

Signal <- t(rbind(signal1,signal2))

imdi, ton1 ve ton2’yi sinyal1 ve sinyal2’den ayırmak istiyoruz. Bunun icin bagimsiz bilesen analizi yontemini kullaniyoruz.

FastICA () kullanarak ICA gerceklestirme

library(fastICA)

b <- fastICA(Signal, 2, alg.typ = "parallel", fun = "logcosh", alpha = 1,
method = "C", row.norm = FALSE, maxit = 200,
tol = 0.0001, verbose = TRUE)

## Centering
## Whitening
## Symmetric FastICA using logcosh approx. to neg-entropy function
## Iteration 1 tol=0.056372
## Iteration 2 tol=0.000061

str(b)

## List of 5
##  $ X: num [1:1000, 1:2] 0.779 0.42 0.698 0.56 0.594 ...
##  $ K: num [1:2, 1:2] -0.167 0.309 1.033 0.559
##  $ W: num [1:2, 1:2] 0.988 -0.153 -0.153 -0.988
##  $ A: num [1:2, 1:2] -1.455 -0.532 2.415 -0.785
##  $ S: num [1:1000, 1:2] -0.00693 0.13289 0.0055 0.05332 0.15565 ...

Logcosh kullanarak simetrik FastICA yaklasimi entropi fonksiyonuna giris icin yineleme ciktilarimizi gorebiliriz. 3 farkli yineleme ciktisi vardir.

Tahmini Ton ve Kaynak Sinyaller

ICA gerceklesmesinden sonra artik karisik iki tonun birbirinden nasil ayrildigini gözlemlemek icin bir grafik cizdiriyoruz. Grafikte gördügümüz gibi, Kirmizi ve mavi kaynak sinyalleri(yani, signal1 ve signal2’yi temsil ediyor.), yesil ve siyah ise tahmini tonları(yani, ton1 ve ton2’yi temsil etmektedir.) ifade etmektedir. Buradan anlasildigi üzere ICA yaklasimi ton1 ve ton2’yi dogru bir sekilde ayirmistir diyebiliriz.

plot(b$S[,1], col="olivedrab3", main = "Kaynak Sinyaller ve Tahmini Tonlar", xlab = "Zaman", ylab = "GEnlik") # first column of S_hat
mtext("Kırmızı ve Mavi Kaynak Sinyaller, Yeşil ve Siyah Tahmini Tonlar")
lines(ton1, col="red3")
lines(b$S[,2], col="black") # second column of S_hat
lines(ton2, col="lightslateblue")